HPAVC/HPAVC CD-ROM.iso/pc/DDPLUS71.ZIP/IBBS.ZIP/IBBS.PAS

Pascal/Delphi Source File | 1995-03-23 | 39.9 KB | 1,334 lines

(***************************************************************************

             Fidonet Compatable InterBBS Unit for inclusion in DDPlus.
                             DreamWARE Communications
              Copyright (c)1993-95 Andy Stewart  All Rights Reserved
                           Last revised March 23, 1995

             If you make ANY modifications to this unit, PLEASE sent
            it to Andy Stewart @ 1:2230/146 or Bob Dalton @ 1:391/3010
               for possible inclusion in the next release of DDPlus.

 ***************************************************************************)
unit ibbs;

INTERFACE

(***************************************************************************
  Var-String checking switch MUST be set to OFF for the copy routine.
 ***************************************************************************)

{$V-}

(***************************************************************************
  Remove '.' to use procedure read_all_messages();
 ***************************************************************************)

{$DEFINE READ_EM}

(***************************************************************************
  Global Variable
 ***************************************************************************)

var
 this_system_address,    { Holds this system's address }
 to_system_address,      { Holds the 'to' system's address }
 netmailpath,            { Holds netmail path }
 the_doorname,           { Holds the Door's name }
 doorpath,               { Holds the Door's path }
 filepath,               { Holds file path }
 outfiles,               { Holds name of directory with files to be compressed }
 infiles,                { Holds name of directory to decompress files to }
 outzip,                 { Holds name of directory with outgoing *.ZIP files }
 inzip: string;          { Holds name of directory with incoming *.ZIP files }

(***************************************************************************
  The only five procedures available externally.
 ***************************************************************************)

{$ifdef READ_EM}
procedure read_all_msgs;
{$endif}
function convert_address(s: string): string;
procedure get_ibbs_incoming;
procedure make_ibbs_outgoing(thefile: string; killfiles: boolean);
procedure make_multi_ibbs_outgoing;

IMPLEMENTATION

(***************************************************************************
  You can play with the memory settings (goes in your main *.PAS file, not
  in this unit, but needed to let you know <g>) to get the proper setting
  for your application.  Set the heapmax too low and you may get a overflow
  RTE.
 ***************************************************************************)

{.$M $4000, 0, 100000}

uses
 dos,
 crt;

(***************************************************************************
  Fidonet message structure.
 ***************************************************************************)

const
 max_msg_lines=150;

type
 text_buff   = array[1..10000] of char;    { Set up Text Buffer }
 message_rec = record                      { Begin *.MSG structure }
 from        : string[35];
 too         : string[35];
 subject     : string[72];
 datetime    : string[19];
 timesread,
 destnode,
 orignode,
 cost,
 orignet,
 destnet,
 replyto,
 attribute,
 nextreply   : word;
 junk        : array[1..12] of byte;
 lines       : integer;
 text        : array[1..max_msg_lines] of string[85];
end;                                       { End *.MSG structure }

(***************************************************************************
  Local - Global Variables
 ***************************************************************************)

var
 cur_msg: message_rec;         { Message record }
 oldfilemode: byte;            { Holds the old filemode }

(***************************************************************************
  function exist();  Returns TRUE if file 'filename' exists, else FALSE.
 ***************************************************************************)

function exist(filename: string): boolean;
var
 dirinfo: searchrec;

begin
 findfirst(filename, anyfile, dirinfo);
 if (doserror = 0) then exist:= true else exist:= false;
end;

(***************************************************************************
  function direxist();  Returns TRUE if directory 'dir' exists, else FALSE.
 ***************************************************************************)

function direxist(dir : dirstr): boolean;
var
 fattr: word;
 temp: file;

begin
 assign(temp, (dir+'.')); getfattr(temp, fattr);
 if (doserror<>0) then direxist:=false else direxist:=((fattr and directory)<>0);
end;

(***************************************************************************
  procedure makepath();  Makes FULL path 'dir'.
 ***************************************************************************)

procedure makepath(dir: string);
var
 retry, b: byte;
 error: word;
 tempdir, dir2, thisdir: string;

begin
  getdir(0,thisdir);
  while dir[Length(dir)]='\' do dec(dir[0]);
  dir2:='';
  repeat
   b:=pos('\',dir);
   if (b<>0) then
    begin
     dir2:=dir2+copy(dir,1,b);
     dir:=copy(dir,b+1,length(dir)-b);
    end else dir2:=dir2+dir;
    tempdir:=dir2;
    if (length(tempdir)>3) then while tempdir[length(tempdir)]='\' do dec(tempdir[0]);
    repeat
     {$I-} chdir(tempdir);  {$I+}
      error:=ioresult;
      if (error<>0)then
       begin
        {$I-} mkdir(tempdir); {$I+}
        error:=ioresult;
       end;
      if (error<>0) then inc(retry) else retry:=0;
    until (error=0) or (retry>3);
  until (b=0) or (error<>0);
  chdir(thisdir);
end;

(***************************************************************************
  procedure killdir();  Deletes directory 'path' and everything inside.
 ***************************************************************************)

procedure killdir(path: pathstr);
Var
 f: file;
 fileInfo: searchrec;
 path2: pathstr;
 s: string;

begin
 if path[length(path)]='\' then delete(path,length(path),1);
 findfirst(path+'\*.*',anyfile,fileInfo);
 while doserror=0 do
  begin
   if (fileinfo.name[1]<>'.')and(fileinfo.attr<>volumeid) then
    if ((fileinfo.attr and directory)=directory) then
      begin
       path2:=path+'\'+fileinfo.name;
       killdir(path2);
      end
     else
      if ((fileinfo.attr and volumeid)<>volumeid) then
       begin
        assign(f,path+'\'+fileinfo.name);
        erase(f);
       end;
      findnext(fileinfo);
    end;
   if (doserror=18) and not ((length(path)=2) and (path[2]=':')) then rmdir(path);
end;

(***************************************************************************
  procedure killmsg();  Deletes file 'path' if it exists.
 ***************************************************************************)

procedure killmsg(path: string);
var
 f: file;

begin
 if exist(path) then
  begin
   assign(f,path);
   erase(f);
  end;
end;

(***************************************************************************
  function cstr();  Converts a longint and under to a string and returns it.
 ***************************************************************************)

function cstr(i:longint):string;
var
 c: string;

begin
 str(i,c);
 cstr:=c;
end;

(***************************************************************************
  function upstr();  Converts a string to all uppercase and returns it.
 ***************************************************************************)

function upstr(s1: string): string;
var
 s2 : string;
 i1: integer;
begin
 s2:='';
 for i1:=1 to length(s1) do s2:=s2+upcase(s1[i1]);
 upstr:=s2;
end;

(***************************************************************************
  function value();  Converts a string to a longint and returns it.
 ***************************************************************************)

function value(I:string): longint;
var
 n: longint;
 n1: integer;

begin
 val(i,n,n1);
 if n1<>0 then
  begin
   i:=copy(i,1,n1-1);
   val(i,n,n1)
  end;
 value:=n;
 if i='' then value:=0;
end;

(***************************************************************************
  function field(); Returns a substring based on a delimiter you pass.
 ***************************************************************************)

function field(s: string; c: char; inst: byte): string;
var
 build: string;
 ik, k, kmax: word;

begin
 s:= s+c+c;
 ik:= 0;
 kmax := length(s);
 build:= '';
 k:= 0;
 while (k <= kmax+1) and (ik < inst) do
  begin
   inc(k);
   If s[k] = c then
    begin
     inc(ik);
     if ik <> inst then build:= '';
    end else build:= build + s[k];
  end;
 if (ik <> inst) then build := '';
 field:= build;
End;

(***************************************************************************
  procedure onek(); Repeats until keypress is in string 's'.  Return key as
  var 'c'.
 ***************************************************************************)

procedure onek(var c: char; s: string);
begin
 repeat
  c:=readkey;
  c:=upcase(c);
 until (pos(c,s)<>0);
end;

(***************************************************************************
  function doexec(); Exec() function with a path search.  Returns DOSERROR.
 ***************************************************************************)

function doexec(a, b: string): integer;
var
 Pgm: Pathstr;
 Temp: string;

begin
 Pgm:='';
 if pos('.',a)<>0 then if not exist(a) then Pgm:= FSearch(a,getenv('PATH')) else Pgm:=a else
  begin
   temp:=a+'.BAT';
   if not exist(temp) then Pgm:=FSearch(Temp,getenv('PATH')) else Pgm:=Temp;
   if Pgm='' then
    begin
     temp:=a+'.COM';
     if not exist(temp) then Pgm:=FSearch(Temp,getenv('PATH')) else Pgm:=Temp;
    end;
   if Pgm='' then
    begin
     temp:=a+'.EXE';
     if not exist(temp) then Pgm:=FSearch(Temp,getenv('PATH')) else Pgm:=Temp;
    end;
  end;
 if Pgm<>'' then
  begin
   If Pos('.BAT', Pgm) <> 0 then
    begin
     b := '/C '+Pgm+' '+b;
     Pgm := GetEnv('COMSPEC');
    end;
  dos.exec(pgm,b);
  doexec:=doserror;
 end;
end;

(***************************************************************************
                              Begin Copy Routines
 ***************************************************************************)

type
 ctype  = (cMOVE,cCOPY);  { cMOVE=Copy and Delete, cCOPY=Copy and NO Delete }
 DTARec =  record         { Data Record }
 filler : array [1..21] of byte;
 attr   : byte;
 time,
 date   : word;
 size   : longint;
 name   : string [12];
end;

var
 OK : integer;    { Holds doserror }
 IP,OP : pathstr; { Infile, Outfile }

(***************************************************************************
   procedure putfattr(); Changes file attributes.  .
   Called from copy_file();.
 ***************************************************************************)

procedure putfattr(FName:string; Rdonly, Hid, Sys, Arch:Boolean);
var
 r: registers;

begin
 FillChar(R,Sizeof(R),0);
 FName := FName+#0;
 with R do
  begin
   AH := $43; AL := 1;
   DS := Seg(FName); DX := ofs(FName)+1;
   if Rdonly then CL := CL or $01;
   if Hid then CL := CL or $02;
   if Sys then CL := CL or $04;
   if Arch then CL := CL or $20;
   msdos(R);
  end;
end;

(***************************************************************************
   function Copier();  Does the real copying/moving.
   Called from copy_file();.
 ***************************************************************************)

function Copier(cWhat: ctype; var orig: string; var nName: string) : integer;
const
 bufsize = $C000;                 { Approx. 48k }

type
 fileBuffer = array [1..bufsize] of byte;

var
 regs: registers;
 src,dst: integer;
 bsize,osize: longint;
 buffer : ^fileBuffer;
 DTABlk : DTARec;
 fError : boolean;

(***************************************************************************
   function checkerror(); Returns TRUE if error, FALSE if not.
   Called from copy_file();.
 ***************************************************************************)

 function checkerror(err: integer) : boolean;
  begin
   checkerror:= (Err <> 0);
   ferror:= (Err <> 0);
   copier:= err;
  end;

(***************************************************************************
   procedure delfile();) Delete file 'fname' if cMOVE is specified.
   Called from copy_file();.
 ***************************************************************************)

 procedure delfile(var fname: string);
 var
  regs: registers;

 begin
  with regs do
   begin
    ah := $43;
    al := 1;
    cx := 0;
    ds := Seg(fName[1]);
    dx := ofs(fName[1]);
    msdos(regs);
    if checkerror(Flags and 1) then exit else
     begin
      ah := $41;
      msdos(regs);
      if checkerror(Flags and 1) then exit;
     end;
    end;
   end;

begin
 Copier := 0;
 FindFirst(orig,Anyfile,SearchRec(DTABlk));
 if checkerror(dosError) then exit;
 with regs do
  begin
   ah := $3D;
   al := 0;
   ds := Seg(orig[1]);
   dx := ofs(orig[1]);
   msdos(regs);
   if checkerror(Flags and 1) then exit else
    begin
     src := ax;
     ah := $3C;
     cx := 0;
     ds := Seg(nName[1]);
     dx := Ofs(nName[1]);
     msdos(regs);
     if checkerror(Flags and 1) then exit else dst := ax;
    end;
  end;
 osize := DTABlk.size;
 while (osize > 0) and not ferror do
  begin
   if osize > bufsize then bsize := bufsize else bsize := osize;
   if BSize > maxavail then BSize := maxavail;
   getmem (buffer, BSize);
   with regs do
    begin
     ah := $3F;
     bx := src;
     cx := bsize;
     ds := Seg(buffer^);
     dx := ofs(buffer^);
     msdos(regs);
     if checkerror(Flags and 1) then else
      begin
       ah := $40;
       bx := dst;
       msdos(regs);
       if checkerror(Flags and 1) then else  if ax < bsize then checkerror(98) else osize := osize - bsize;
      end;
    end;
   freemem(buffer, BSize);
  end;
 if not ferror and (cWHAT = cMOVE) then
  with regs do
   begin
    ah := $57;
    al := 1;
    bx := dst;
    cx := DTABlk.time;
    dx := DTABlk.date;
    msdos(regs);
    checkerror(Flags and 1);
   end;
  with regs do
   begin
    ah := $3E;
    bx := src;
    msdos(regs);
    ferror := ferror or ((flags and 1) <> 0);
    ah := $3E;
    bx := dst;
    msdos(regs);
    ferror := ferror or ((flags and 1) <> 0)
   end;
  if ferror then exit else
   with regs do
    begin
     ah := $43;
     al := 1;
     cx := DTABlk.attr;
     ds := Seg(nName[1]);
     dx := ofs(nName[1]);
     msdos(regs);
     if checkerror(Flags and 1) then exit else if (cWHAT = cMOVE) then delFile(orig)
    end;
end;

(***************************************************************************
  function copy_file();  Copies file 'IP' to file 'OP', sets attribute to
  Archive, and returns errorcode.
 ***************************************************************************)

function copy_file(from, too: string): integer;
begin
 IP:=from; OP:=too;
 copy_file:= Copier(cCOPY,IP,OP);
 if exist(OP) then PutFAttr(OP,false,false,false,true);
end;

(***************************************************************************
                               End Copy Routines
 ***************************************************************************)

(***************************************************************************
  function convert_address();  Converts a Fidonet style address to a
  string suitable for use as a filename.  (IE:  1:2230/146 would be
  converted to 12230146)
 ***************************************************************************)

function convert_address(s: string): string;
var
 s1: string[8];
 i: byte;

begin
 s1:='';
 for i:=1 to length(s) do
  begin
   if ((s[i]<>':') and (s[i]<>'/') and (s[i]<>'.')) then s1:=s1+s[i];
  end;
 convert_address:=s1;
end;

(***************************************************************************
  procedure compress_outgoing();  ZIP's up all files in the outgoing
  directory (outfiles) into a file called ????????.ZIP (passed as 'filename')
  in the outgoing ZIP directory (outzip).  If successful, outfile\*.* is
  deleted.
 ***************************************************************************)

procedure compress_outgoing(filename: string; killem: boolean);
var
 error: integer;

begin
 error:=doexec('PKZIP.EXE','-EX '+outzip+filename+' '+outfiles+'*.*');
 if error<>0 then
  begin
   writeln(^G^G,#254,'  ERROR:  Errorcode:= ',error);
   delay(2500);
  end
 else if killem then
  begin
   killdir(outfiles);
   makepath(outfiles);
  end;
end;

(***************************************************************************
  procedure decompress();  Decompresses all ZIP files in incoming directory
  (inzip) into the infiles directory (infiles).  If successfule, all ZIP
  files are deleted.
 ***************************************************************************)

procedure decompress_incoming;
var
 error: integer;
 dirinfo: searchrec;
 f: file;

begin
 findfirst('*.ZIP',archive,dirinfo);
 while doserror=0 do
  begin
   error:=doexec('PKUNZIP.EXE','-EX '+inzip+dirinfo.name+' '+infiles);
   if error<>0 then
    begin
     writeln(^G^G,#254,'  ERROR:  Errorcode:= ',error);
     delay(2500);
    end
   else
    begin
     assign(f,outfiles+dirinfo.name);
     erase(f);
    end;
   findnext(dirinfo);
  end;
end;

(***************************************************************************
  procedure get_message();  Does the actual reading of *.MSG files.
  Called from get_ibbs_incoming(); and read_all_messages().
 ***************************************************************************)

procedure get_message(file_name: string; var cur_msg: message_rec);
type
 msg_buff=array[1..65535] of char;
 msg_buff_ptr=^msg_buff;

var
 ss: array[1..2] of char;
 c: integer absolute ss;
 d: integer;
 message_buffer: msg_buff_ptr;
 f: file;
 l, a, bfcnt: integer;
 b: boolean;
 ch: char;
 s: string;

begin
 oldfilemode:=filemode;
 filemode:=64;
 assign(f,file_name);
 {$I-}
 filemode:=66;
 reset(f,128);
 filemode:=2;
 {$I+}
 if ioresult<>0 then cur_msg.from:='DELETED' else
  begin
   getmem(message_buffer,(filesize(f)+2)*128);
   for a:=1 to (filesize(f)+2)*128 do message_buffer^[a]:=#0;
   blockread(f,message_buffer^,filesize(f)+1,a);
   cur_msg.from:='';
   cur_msg.too:='';
   cur_msg.subject:='';
   cur_msg.datetime:='';
   b:=true;
   for a:=1 to 36 do
    begin
     if message_buffer^[a]=#0 then b:=false;
     if b then cur_msg.from:=cur_msg.from+message_buffer^[a];
    end;
   b:=true;
  for a:=37 to 73 do
   begin
    if message_buffer^[a]=#0 then b:=false;
    if b then cur_msg.too:=cur_msg.too+message_buffer^[a];
   end;
  b:=true;
  for a:=73 to 145 do
   begin
    if message_buffer^[a]=#0 then b:=false;
    if b then cur_msg.subject:=cur_msg.subject+message_buffer^[a];
   end;
  b:=true;
  for a:=145 to 165 do
   begin
    if message_buffer^[a]=#0 then b:=false;
    if b then cur_msg.datetime:=cur_msg.datetime+message_buffer^[a];
   end;
  ss[1]:=message_buffer^[167];
  ss[2]:=message_buffer^[168];
  cur_msg.destnode:=c;
  ss[1]:=message_buffer^[169];
  ss[2]:=message_buffer^[170];
  cur_msg.orignode:=c;
  ss[1]:=message_buffer^[171];
  ss[2]:=message_buffer^[172];
  cur_msg.cost:=c;
  ss[1]:=message_buffer^[173];
  ss[2]:=message_buffer^[174];
  cur_msg.orignet:=c;
  ss[1]:=message_buffer^[175];
  ss[2]:=message_buffer^[176];
  cur_msg.destnet:=c;
  ss[1]:=message_buffer^[185];
  ss[2]:=message_buffer^[186];
  cur_msg.replyto:=c;
  ss[1]:=message_buffer^[187];
  ss[2]:=message_buffer^[188];
  cur_msg.attribute:=c;
  ss[1]:=message_buffer^[189];
  ss[2]:=message_buffer^[190];
  cur_msg.nextreply:=c;
  l:=1;
  for a:=1 to 100 do cur_msg.text[a]:='';
  bfcnt:=191;
  repeat
   ch:=message_buffer^[bfcnt];
   bfcnt:=succ(bfcnt);
   if ch=#$0D then inc(l);
   if not (ch in [#$0d,#$8d,#$0a,#0]) then cur_msg.text[l]:=cur_msg.text[l]+ch;
   if (length(cur_msg.text[l])=79) then
    begin
     d:=0;
     for c:=length(cur_msg.text[l]) downto 1 do
      begin
       if (d=0) and (cur_msg.text[l][c]=' ') then d:=c;
      end;
    s:='';
    if d>60 then
     begin
      while length(cur_msg.text[l])>=d do
       begin
        s:=s+cur_msg.text[l][length(cur_msg.text[l])];
        delete(cur_msg.text[l],length(cur_msg.text[l]),1);
       end;
      for a:=length(s)-1 downto 1 do cur_msg.text[l+1]:=cur_msg.text[l+1]+s[a];
     end;
    inc(l);
    end;
   if l>=99 then
    begin
     cur_msg.text[99]:='<Error: Too many lines in message>';
     l:=99;
     ch:=#0;
    end;
  until ch=chr(0);
  cur_msg.lines:=l;
  freemem(message_buffer,(filesize(f)+2)*128);
  close(f);
 end;
 filemode:=oldfilemode;
end;

(***************************************************************************
  procedure write_message();  Does the actual writing of *.MSG files.
  Called from make_ibbs_outgoing();.
 ***************************************************************************)

procedure write_message(file_name: string; var cur_msg: message_rec);
var
 f: file of char;
 i, i1: integer;
 ch, ch1: char;
 cr: char;
 space: char;
 soft_cr: char;
 ss: array[1..10] of char;

begin
 while length(cur_msg.subject)>71 do delete(cur_msg.subject,length(cur_msg.subject),1);
 i1:=0;
 assign(f,file_name);
 rewrite(f);
 for i:=1 to length(cur_msg.from) do
  begin
   write(f,cur_msg.from[i]);
   inc(i1);
  end;
 space:=#32; ch:=#0; ch1:=#01; cr:=#$0d; soft_cr:=#$08d;
 while i1<36 do
  begin
   write(f,ch);
   inc(i1);
  end;
 for i:=1 to length(cur_msg.too) do
  begin
   write(f,cur_msg.too[i]);
   inc(i1);
  end;
 while i1<72 do
  begin
   write(f,ch);
   inc(i1);
  end;
 for i:=1 to length(cur_msg.subject) do
  begin
   write(f,cur_msg.subject[i]);
   inc(i1);
  end;
 while i1<144 do
  begin
   write(f,ch);
   inc(i1);
  end;
 for i:=1 to length(cur_msg.datetime) do
  begin
   write(f,cur_msg.datetime[i]);
   inc(i1);
  end;
 while i1<164 do
  begin
   write(f,ch);
   inc(i1);
  end;
 write(f,ch1,ch);
 with cur_msg do
  begin
   ss[1]:=chr(lo(destnode));
   ss[2]:=chr(hi(destnode));
   ss[3]:=chr(lo(orignode));
   ss[4]:=chr(hi(orignode));
   ss[5]:=chr(lo(cost));
   ss[6]:=chr(hi(cost));
   ss[7]:=chr(lo(orignet));
   ss[8]:=chr(hi(orignet));
   ss[9]:=chr(lo(destnet));
   ss[10]:=chr(hi(destnet));
   for i:=1 to 10 do write(f,ss[i]);
   write(f,ch,ch,ch,ch,ch,ch,ch,ch);
   ss[1]:=chr(lo(replyto));
   ss[2]:=chr(hi(replyto));
   ss[3]:=chr(lo(attribute));
   ss[4]:=chr(hi(attribute));
   ss[5]:=chr(lo(nextreply));
   ss[6]:=chr(hi(nextreply));
   for i:=1 to 6 do write(f,ss[i]);
  end;
 for i:=1 to cur_msg.lines do
  begin
   for i1:=1 to length(cur_msg.text[i]) do write(f,cur_msg.text[i][i1]);
   if cur_msg.text[i][length(cur_msg.text[i])]<>#13 then write(f,space);
  end;
 write(f,ch);
 close(f);
end;

(***************************************************************************
  function find_high_message(); Returns value of highest *.MSG file found
  in path 'path'.  Called from make_ibbs_outgoing();.
 ***************************************************************************)

function find_high_message(path: string): word;
var
 sr: searchrec;
 a, b, highmsg: integer;
 s: string;

begin
 highmsg:=0; s:='';
 findfirst(path+'\'+'*.msg',anyfile,sr);
 for a:=1 to pos('.',sr.name)-1 do s:=s+sr.name[a];
 a:=value(s);
 if a<>0 then if a>highmsg then highmsg:=a;
 while doserror=0 do
  begin
   findnext(sr);
   s:='';
   for a:=1 to pos('.',sr.name)-1 do s:=s+sr.name[a];
   a:=value(s);
   if a<>0 then if a>highmsg then highmsg:=a;
  end;
 find_high_message:=highmsg;
end;

(***************************************************************************
  function fidodate;  Returns current date in Fido format.
  Called from make_ibbs_outgoing();.
 ***************************************************************************)

function fidodate: string;
const
 months: array[1..12] of string[3] = ('Jan', 'Feb', 'Mar', 'Apr',
                                       'May', 'Jun', 'Jul', 'Aug',
                                       'Sep', 'Oct', 'Nov', 'Dec');

var
 y, m, d, w: word;
 h, mn, sc, s100: word;
 s, s2: string;

begin
 getdate(y,m,d,w);
 y:=y-1900;
 s:=cstr(d);
 if length(s)=1 then s:='0'+s;
 s:=s+' '+months[m]+' '+cstr(y)+'  ';
 gettime(h,mn,sc,s100);
 s2:=cstr(h);
 if length(s2)=1 then s2:='0'+s2;
 s:=s+s2+':'; s2:=cstr(mn);
 if length(s2)=1 then s2:='0'+s2;
 s:=s+s2+':'; s2:=cstr(sc);
 if length(s2)=1 then s2:='0'+s2;
 s:=s+s2;
 s:=s+#0;
 while length(s)>20 do delete(s,length(s),1);
 fidodate:=s;
end;

(***************************************************************************
  function getbit();  Returns TRUE if specified bit is set else FALSE.
  Called from togglebit(); and do_bit.
 ***************************************************************************)

function getbit(the_bit: word; which_bit: byte): boolean;
begin
 if (the_bit and (1 shl which_bit))<>0 then getbit:=true else getbit:=false;
end;

(***************************************************************************
  function setbit();  If setit=true, the specified bit is set, else it's
  cleared.  Called from togglebit(); and make_ibbs_outgoing();.
 ***************************************************************************)

procedure setbit(var the_bit: word; which_bit: byte; setit: boolean);
begin
 if setit then the_bit:=the_bit or (1 shl which_bit) else the_bit:=the_bit and not (1 shl which_bit);
end;

(***************************************************************************
  function togglebit();  Toggles the status of the specified bit
  Not used.
 ***************************************************************************)

procedure togglebit(var the_bit: word; which_bit: byte);
begin
 if getbit(the_bit,which_bit) then setbit(the_bit,which_bit,false) else setbit(the_bit,which_bit,true)
end;

(***************************************************************************
  function do_bit();  Reports which bit(s) in cur_msg.attributes are ON.
  Called from read_all_msgs();.
 ***************************************************************************)

{$IFDEF READ_EM}
procedure do_bit(the_bit, num: word);
begin
 case num of
  0 : if getbit(the_bit,num) then writeln('Private Message');
  1 : if getbit(the_bit,num) then writeln('Crashmail');
  2 : if getbit(the_bit,num) then writeln('Message Was Read');
  3 : if getbit(the_bit,num) then writeln('Message Was Sent');
  4 : if getbit(the_bit,num) then writeln('File Attatched, Filename(s) In Subject');
  5 : if getbit(the_bit,num) then writeln('Forwarded Message');
  6 : if getbit(the_bit,num) then writeln('Orphan Message');
  7 : if getbit(the_bit,num) then writeln('Kill After It''s Sent');
  8 : if getbit(the_bit,num) then writeln('Message Originated Here (Local)');
  9 : if getbit(the_bit,num) then writeln('Hold');
 10 : if getbit(the_bit,num) then writeln('Reserved');
 11 : if getbit(the_bit,num) then writeln('File Request, Filename(s) In Subject');
 12 : if getbit(the_bit,num) then writeln('Return Receipt Requested');
 13 : if getbit(the_bit,num) then writeln('This message is a Return Receipt');
 14 : if getbit(the_bit,num) then writeln('Audit Trail Requested');
 15 : if getbit(the_bit,num) then writeln('Update Request');
 end;
end;
{$ENDIF}

(***************************************************************************
  procedure read_all_msgs();  Displays all *.MSG files in path 'path'.
 ***************************************************************************)

{$ifdef READ_EM}
procedure read_all_msgs;
var
 ii: byte;
 dirinfo: searchrec;

begin
 findfirst(netmailpath+'*.MSG',archive,dirinfo);
 while doserror=0 do
  begin
   clrscr;
   writeln('Message: ',dirinfo.name);
   get_message(netmailpath+dirinfo.name, cur_msg);
   writeln('From: ',cur_msg.from,'  ',cur_msg.orignet,'/',cur_msg.orignode);
   writeln('To  : ',cur_msg.too,'  ',cur_msg.destnet,'/',cur_msg.destnode);
   writeln('Date/Time: ',cur_msg.datetime);
   writeln('Subject: ',cur_msg.subject);
   writeln('Attr: ',cur_msg.attribute);
   for ii:=0 to 15 do do_bit(cur_msg.attribute,ii);
   for ii:=1 to 80 do write(#254);
   window(1,wherey,80,25);
   for ii:=1 to cur_msg.lines do writeln(cur_msg.text[ii]);
   readkey;
   window(1,1,80,25);
   findnext(dirinfo);
  end;
end;
{$endif}

(***************************************************************************
  procedure get_ibbs_incoming();  Checks all incoming netmailpath\*.MSG
  files for messages addresses to 'name' @ 'this_system_address', moves
  file found in 'filepath' to 'doorpath\inzip' and deletes the *.MSG.
 ***************************************************************************)

procedure get_ibbs_incoming;
var
 ok: boolean;
 i, i1: word;
 b, b1: byte;
 tempstr, tostr, fromstr, thefile: string;
 dirinfo: searchrec;

begin
 i1:=0; tostr:=''; fromstr:='';
 for i:=1 to cur_msg.lines do
  begin
   if pos('IBBS:',cur_msg.text[i])<>0 then i1:=i;
   if i1<>0 then i:=cur_msg.lines;
  end;
 if i1<>0 then
  begin
   tostr:=field(cur_msg.text[i1],#32,2);
   fromstr:=field(cur_msg.text[i1],#32,3);
  end;
 findfirst(netmailpath+'*.MSG',archive,dirinfo);
 while doserror=0 do
  begin
   clrscr; tempstr:=''; ok:=true;
   writeln('Message: ',dirinfo.name);
   get_message(netmailpath+dirinfo.name, cur_msg);
   for i:=1 to cur_msg.lines do
    begin
     if pos('TID',cur_msg.text[i])<>0 then tempstr:=cur_msg.text[i];
     if tempstr<>'' then i:=cur_msg.lines;
    end;
   if tempstr<>'' then if (pos('IBBS / '+the_doorname,tempstr)<>0) then ok:=true else ok:=false;
   if ((upstr(cur_msg.too) = (upstr(the_doorname))) and (tostr=this_system_address) and (ok)) then
    begin
     thefile:=cur_msg.subject;
     if pos('\',thefile)<>0 then
      begin
       for b:=1 to length(thefile) do if thefile[b]='\' then b1:=b;
       delete(thefile,1,b1);
      end;
     writeln('Copying ',upstr(filepath+thefile),' to ',upstr(doorpath+inzip+thefile));
     if exist(filepath+thefile) then
      writeln('Return Code: ',copy_file(filepath+thefile,doorpath+inzip+thefile))
       else writeln(upstr(filepath+thefile),' doesn''t exist!');
     killmsg(netmailpath+dirinfo.name);
     writeln('Killing: ',upstr(netmailpath+dirinfo.name));
    end;
   findnext(dirinfo);
 end;
 decompress_incoming;
end;

(***************************************************************************
  procedure make_ibbs_outgoing();  Creates the outgoing netmailpath\*.MSG.
  Sets message as: To 'doorname' @ 'toaddr', From 'doorname' @ 'fromaddr',
  subjext is 'thefile', set as attributes/flags are set as Pvt, Local, File,
  Kill, Del/Sent, Direct.
 ***************************************************************************)

procedure make_ibbs_outgoing(thefile: string; killfiles: boolean);
var
 i: word;
 save_this, too, from, tnode, fnode, tnet, fnet: string;

begin
 save_this:=this_system_address;
 clrscr; writeln('Sending '+upstr(thefile)+'.ZIP to '+to_system_address);
 compress_outgoing(thefile,killfiles);
 thefile:=doorpath+outzip+thefile+'.ZIP';
 if exist(thefile) then
  begin
   too:=''; from:=''; tnode:=''; tnet:=''; fnet:=''; i:=0;
   i:=find_high_message(netmailpath)+1;
   too:=to_system_address; from:=this_system_address;
   while to_system_address[1]<>':' do delete(to_system_address,1,1);
   delete(to_system_address,1,1);
   while to_system_address[1]<>'/' do
    begin tnet:=tnet+to_system_address[1]; delete(to_system_address,1,1); end;
   delete(to_system_address,1,1);
   tnode:=to_system_address;
   while this_system_address[1]<>':' do delete(this_system_address,1,1);
   delete(this_system_address,1,1);
   while this_system_address[1]<>'/' do
    begin fnet:=fnet+this_system_address[1]; delete(this_system_address,1,1); end;
   delete(this_system_address,1,1);
   fnode:=this_system_address;
   cur_msg.from:=the_doorname;
   cur_msg.too:=the_doorname;
   cur_msg.subject:=upstr(thefile);
   cur_msg.datetime:=fidodate;
   cur_msg.destnode:=value(tnode);
   cur_msg.orignode:=value(fnode);
   cur_msg.cost:=11;
   cur_msg.orignet:=value(fnet);
   cur_msg.destnet:=value(tnet);
   setbit(cur_msg.attribute,0,true);
   setbit(cur_msg.attribute,1,true);
   setbit(cur_msg.attribute,2,false);
   setbit(cur_msg.attribute,3,false);
   setbit(cur_msg.attribute,4,true);
   setbit(cur_msg.attribute,5,false);
   setbit(cur_msg.attribute,6,false);
   setbit(cur_msg.attribute,7,true);
   setbit(cur_msg.attribute,8,true);
   setbit(cur_msg.attribute,9,false);
   setbit(cur_msg.attribute,10,false);
   setbit(cur_msg.attribute,11,false);
   setbit(cur_msg.attribute,12,false);
   setbit(cur_msg.attribute,13,false);
   setbit(cur_msg.attribute,14,false);
   setbit(cur_msg.attribute,15,false);
   cur_msg.lines:=4;
   cur_msg.text[1]:=#1+'IBBS: '+too+' '+from+' '+#10+#13;
   cur_msg.text[2]:=#1+'INTL '+too+' '+from+' '+#10+#13;
   cur_msg.text[3]:=#1+'FLAGS DIR KFS'+#10+#13;
   cur_msg.text[4]:=#1+'TID: IBBS / '+the_doorname+#10+#13;
   write_message(netmailpath+cstr(i)+'.MSG', cur_msg);
   this_system_address:=save_this;
  end
 else writeln(upstr(thefile)+' doesn''t exist!');
end;

(***************************************************************************
   procedure make_multi_ibbs_outgoing();  Reads each line in ROUTE.CFG,
   and calls make_ibbs_outgoing for each line.
 ***************************************************************************)

procedure make_multi_ibbs_outgoing;
var
 t: text;
 savenode, s: string;

begin
 savenode:=to_system_address;
 if not exist('ROUTE.CFG') then
  begin
   writeln(^G^G,#254,'  ERROR:  ROUTE.CFG Does NOT exist!');
   delay(2500);
  end
 else
  begin
   assign(t,'ROUTE.CFG');
   reset(t);
   while not eof(t) do
    begin
     readln(t,s);
     if ((s<>'') and (s[1]<>';')) then
      begin
       to_system_address:=field(s,';',1);
       make_ibbs_outgoing(field(s,';',2),false);
      end;
    end;
   close(t);
   killdir(outfiles);
   makepath(outfiles);
  end;
 to_system_address:=savenode;
end;

(***************************************************************************
  procedure read_config();  Reads the IBBS.CFG file, or creates it if it
  doesn't exist.
 ***************************************************************************)

procedure read_config;
var
 t: text;

procedure ask_dir(path: string);
var
 sel: char;

begin
 if path[length(path)]<>'\' then path:=path+'\';
 write(upstr(path)+' doesn''t exist, create it [Y/n]: ');
 onek(sel,'YN'+#13+#10);
 case sel of
  #10,
  #13,
  'Y': begin
        writeln('Yes');
        makepath(path);
       end;
  'N': writeln('Yes');
 end;
end;


begin
 getdir(0,doorpath);
 if not exist('IBBS.CFG') then
  begin
   assign(t,'IBBS.CFG');
   rewrite(t);
   clrscr;
   writeln('IBBS.CFG doesn''t exist.  Creating now...'); writeln;
   repeat
    write('Enter your net address [ie: 1:2230/146]              : '); readln(this_system_address);
   until this_system_address<>'';
   repeat
    write('Enter the TO net address [ie: 1:391/3010]            : '); readln(to_system_address);
   until to_system_address<>'';
   repeat
    write('Enter the door''s name                                : '); readln(the_doorname);
   until the_doorname<>'';
   repeat
    write('Enter your FULL netmail path [ie: C:\FD\NETMAIL\]    : '); readln(netmailpath);
    if not direxist(netmailpath) then ask_dir(netmailpath);
   until direxist(netmailpath) and (netmailpath<>'');
   repeat
    write('Enter your FULL incoming files path [ie:C:\FD\FILE\] : '); readln(filepath);
    if not direxist(filepath) then ask_dir(filepath);
   until direxist(filepath) and (filepath<>'');
   repeat
    write('Enter your UNZIP directory NAME [ie: INFILES]        : '); readln(infiles);
    if not direxist(infiles) then ask_dir(infiles);
   until direxist(infiles) and (infiles<>'');
   repeat
    write('Enter your ZIP files directory NAME [ie: OUTFILES]   : '); readln(outfiles);
    if not direxist(outfiles) then ask_dir(outfiles);
   until direxist(outfiles) and (outfiles<>'');
   repeat
    write('Enter your outgoing ZIP directory NAME [ie: OUTZIP]  : '); readln(outzip);
    if not direxist(outzip) then ask_dir(outzip);
   until direxist(outzip) and (outzip<>'');
   repeat
    write('Enter your incoming ZIP directory NAME [ie: INZIP]   : '); readln(inzip);
    if not direxist(inzip) then ask_dir(inzip);
   until direxist(inzip) and (inzip<>'');
   writeln(t,this_system_address);
   writeln(t,to_system_address);
   writeln(t,the_doorname);
   writeln(t,upstr(netmailpath));
   writeln(t,upstr(filepath));
   writeln(t,upstr(infiles));
   writeln(t,upstr(outfiles));
   writeln(t,upstr(outzip));
   writeln(t,'');
   writeln(t,'(**************  IBBS.CFG - Everything after line 9 is ignored. ************)');
   writeln(t,'Line 1:  Your Net Address');
   writeln(t,'Line 2:  The To Net Address');
   writeln(t,'Line 3:  This Door''s Name');
   writeln(t,'Line 4:  Netmail Path');
   writeln(t,'Line 5:  Incoming File Path');
   writeln(t,'Line 6:  Name Of Directory To Decompress Incoming Files To');
   writeln(t,'Line 7:  Name Of Directory Holding Outgoing Files To Be Compressed');
   writeln(t,'Line 8:  Name Of Directory Holding Compressed Outgoing Files');
   writeln(t,'Line 9:  Name Of Directory Holding Compressed Incoming Files');
   close(t);
  end;
 assign(t,'IBBS.CFG');
 reset(t);
 readln(t,this_system_address);
 readln(t,to_system_address);
 readln(t,the_doorname);
 readln(t,netmailpath);
 readln(t,filepath);
 readln(t,infiles);
 readln(t,outfiles);
 readln(t,outzip);
 readln(t,inzip);
 close(t);
end;

(***************************************************************************
  procedure check_dirs();  Insures all the directories exist, and creates
  them if not.
 ***************************************************************************)

procedure check_dirs;
begin
 if not direxist(netmailpath) then makepath(netmailpath);
 if not direxist(filepath) then makepath(filepath);
 if not direxist(infiles) then makepath(infiles);
 if not direxist(outfiles) then makepath(outfiles);
 if not direxist(outzip) then makepath(outzip);
 if not direxist(inzip) then makepath(inzip);
end;

(***************************************************************************
  procedure check_slashes();  Insures all the directory names have a
  trailing backslash, and appens one if not.
 ***************************************************************************)

procedure check_slashes;
begin
 if outfiles[length(outfiles)]<>'\' then outfiles:=outfiles+'\';
 if infiles[length(infiles)]<>'\' then infiles:=infiles+'\';
 if outzip[length(outzip)]<>'\' then outzip:=outzip+'\';
 if inzip[length(inzip)]<>'\' then inzip:=inzip+'\';
 if netmailpath[length(netmailpath)]<>'\' then netmailpath:=netmailpath+'\';
 if filepath[length(filepath)]<>'\' then filepath:=filepath+'\';
 if doorpath[length(doorpath)]<>'\' then doorpath:=doorpath+'\';
end;

(***************************************************************************
                              Begin Main Block
 ***************************************************************************)

BEGIN
 read_config;
 check_slashes;
 check_dirs;
END.



{ IBBS.CFG

1:2230/146
1:391/3010
DoorName
C:\FD\NETMAIL\
C:\FD\FILE\
INFILES
OUTFILES
OUTZIP
INZIP

(**************  IBBS.CFG - Everything after line 9 is ignored. ************)
Line 1:  Your Net Address
Line 2:  The To Net Address
Line 3:  This Door's Name
Line 4:  Netmail Path
Line 5:  Incoming File Path
Line 6:  Name Of Directory To Decompress Incoming Files To
Line 7:  Name Of Directory Holding Outgoing Files To Be Compressed
Line 8:  Name Of Directory Holding Compressed Outgoing Files
Line 9:  Name Of Directory Holding Compressed Incoming Files

}